home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / docs.lha / doc-diff.lisp < prev    next >
Lisp/Scheme  |  1991-06-22  |  16KB  |  394 lines
  1. ;;; -*- Package: Hemlock -*-
  2. ;;;
  3. ;;;    A hack to compare the functions and variables defined by the hemlock
  4. ;;; documents with the ones defined in the core.
  5. ;;;
  6. ;;; Use GROVEL-LABELS.
  7. ;;;
  8.  
  9. (in-package "HEMLOCK")
  10.  
  11.  
  12. (defvar *defined-labels* (make-hash-table :test #'equal))
  13.  
  14. ;;; Ignore these because they would be internal (not for the user) if Hemlock
  15. ;;; had that kind of definition power.
  16. ;;;
  17. (defvar *hvars-to-ignore*
  18.   '(auto-save-state current-package draft-information headers-buffer
  19.     headers-information message-buffer message-information spell-information
  20.     default-message-modeline-fields current-compile-server current-eval-server))
  21.  
  22. (defvar *cmds-to-ignore*
  23.   '("Beginning Of Parse" "Echo Area Backward Character"
  24.     "Echo Area Backward Word" "Echo Area Delete Previous Character"
  25.     "Echo Area Kill Previous Word" "Do Nothing" "Illegal" "Insert Parse Default"
  26.     "Italic Comment Mode" "Kill Parse" "Lisp Insert )" "Next Parse"
  27.     "Previous Parse" "Start Italic Comment" "Insert ()" "Move over )"
  28.     "Current Compile Server" "Current Eval Server" "Defhvar" "Defindent"))
  29.  
  30. ;;; These do not get removed from *defined-labels* because they are not
  31. ;;; command names, variable names, or "HI" function names.  These are now
  32. ;;; documented in the Command Implementor's Manual, but we don't want to call
  33. ;;; FIND-UNDOCUMENTED-SYMBOLS on these packages due to all the uninteresting
  34. ;;; symbols they hold.  In the case of routines defined in the "ED" package,
  35. ;;; they aren't exported anyway.
  36. ;;;
  37. ;;; Do not add names to this list that occur in the ED package and have
  38. ;;; asterisks (e.g., specials like *kill-ring* and *last-search-string*).  Use
  39. ;;; the variable below, *unimplemented-strings-to-ignore*.
  40. ;;;
  41. (defvar *unimplemented-to-ignore*
  42.   '(spell:spell-try-word spell:maybe-read-spell-dictionary spell:spell-root-word
  43.     spell:max-entry-length spell:spell-read-dictionary
  44.     spell:spell-collect-close-words spell:correct-spelling
  45.     spell:spell-add-entry spell:spell-remove-entry spell:spell-root-flags
  46.  
  47.     ext:define-keysym ext:make-key-event-bits ext:key-event-bits
  48.     ext:define-mouse-keysym ext:do-alpha-key-events ext:key-event-modifier-mask
  49.     ext:print-pretty-key ext:name-keysym ext:key-event-char
  50.     ext:keysym-preferred-name ext:define-key-event-modifier ext:keysym-names
  51.     ext:key-event-p ext:make-key-event ext:define-clx-modifier
  52.     ext:key-event-bits-modifiers ext:char-key-event
  53.     ext:translate-mouse-key-event ext:key-event-keysym ext:key-event-bit-p
  54.     ext:print-pretty-key-event ext:translate-key-event
  55.  
  56.     dired:find-file dired:make-directory dired:delete-file
  57.     dired:pathnames-from-pattern dired:copy-file dired:rename-file
  58.  
  59.     get-search-pattern current-mark file-compile kill-characters
  60.     indent-region-for-commands display-page-directory previous-buffer
  61.     sentence-offset interactive buffer-default-pathname
  62.     add-definition-dir-translation push-buffer-mark do-active-group
  63.     paragraph-offset word-offset create-slave make-region-undo
  64.     process-file-options pre-command-parse-check top-level-offset fill-region
  65.     pop-buffer-mark region-eval get-current-compile-server mark-top-level-form
  66.     ed page-directory find-file-buffer deactivate-region valid-spot
  67.     buffer-history kill-region string-eval backward-up-list
  68.     define-file-type-hook buffer-history check-region-query-size
  69.     change-to-buffer region-compile current-region mark-paragraph form-offset
  70.     check-region-active read-buffer-file fill-region-by-paragraphs
  71.     forward-up-list define-file-option buffer-mark region-active-p
  72.     inside-defun-p activate-region start-defun-p delete-buffer-if-possible
  73.     get-current-eval-server goto-page write-buffer-file save-for-undo
  74.     eval-form-in-server eval-form-in-server-1 indent-region in-lisp
  75.     pathname-to-buffer-name page-offset defun-region
  76.     delete-definition-dir-translation delete-horizontal-space
  77.     supply-generic-pointer-up-function))
  78.  
  79. ;;; This is just like *unimplemented-to-ignore*, but these names are hard to
  80. ;;; deal with in *unimplemented-to-ignore* due to one of the following reasons:
  81. ;;;    Scribe,
  82. ;;;    The name is an example and truly unimplemented, or
  83. ;;;    The name has asterisks in core but not in the Scribe label name.
  84. ;;;
  85. (defvar *unimplemented-strings-to-ignore*
  86.   '("SAMPLECOMMAND" "SAMPLEVARIABLE"
  87.  
  88.     "MARK-GTR" "MARK-NEQ" "MARK-LSS" "MARK-LEQ" "MARK-GEQ" "MARK-EQL"
  89.     "LINE-GEQ" "LINE-LSS" "LINE-GTR" "LINE-LEQ"
  90.  
  91.     "KILL-RING" "LAST-SEARCH-STRING" "EPHEMERALLY-ACTIVE-COMMAND-TYPES"
  92.     "HEMLOCK-BEEP" "LAST-SEARCH-PATTERN" "ACTIVE-FILE-GROUP"
  93.  
  94.     "ALL-MODIFIER-NAMES"
  95.  
  96.     "ERROR-FUNCTION" "REPORT-FUNCTION" "UPDATE-DEFAULT" "YESP-FUNCTION"
  97.     "CLOBBER-DEFAULT" "RECURSIVE-DEFAULT"))
  98.  
  99.  
  100. (defun grovel-labels (aux-files output-file)
  101.   "Read each of the files in the list Aux-Files to find what commands are
  102.   documented, then compare it with the commands defined in core.  We write
  103.   documentation forms to the output-file for things defined but not documented,
  104.   and we put a list of things documented but not implemented in a comment."
  105.   (clrhash *defined-labels*)
  106.   (dolist (labels-file aux-files)
  107.     (with-open-file (s labels-file :direction :input)
  108.       (loop
  109.     (let ((l (read-line s nil nil)))
  110.       (unless l (return))
  111.       (multiple-value-bind (kind label)
  112.                    (parse-label l)
  113.         (when kind
  114.           (let ((old (gethash label *defined-labels*)))
  115.         (when (and old
  116.                (not (eq old :hemlock-variable))
  117.                (not (eq kind :hemlock-variable)))
  118.           (format t "~S multiply defined as ~S and ~S.~%"
  119.               label old kind))
  120.         (setf (gethash label *defined-labels*) kind))))))))
  121.   (with-open-file (s output-file :direction :output
  122.              :if-exists :new-version)
  123.     (map-undocumented-hemlock-things *command-names* :command s
  124.                      #'document-command *cmds-to-ignore*)
  125.     (terpri s)
  126.     (map-undocumented-hemlock-things *global-variable-names* :hemlock-variable s
  127.                      #'document-variable *hvars-to-ignore*)
  128.     (terpri s)
  129.     (find-undocumented-symbols "HEMLOCK-INTERNALS" s)
  130.     (terpri s)
  131.     (write-line "@begin[comment]" s)
  132.     (let ((ignored-symbols (copy-list *unimplemented-to-ignore*))
  133.       (ignored-strings (copy-list *unimplemented-strings-to-ignore*)))
  134.       (maphash #'(lambda (name type)
  135.            (cond ((member name ignored-symbols
  136.                   :test #'string= :key #'symbol-name)
  137.               (setf ignored-symbols
  138.                 (delete name ignored-symbols
  139.                     :test #'string= :key #'symbol-name)))
  140.              ((member name ignored-strings :test #'string=)
  141.               (setf ignored-strings
  142.                 (delete name ignored-strings :test #'string=)))
  143.              (t
  144.               (format s "~A ~S is not implemented.~%" type name))))
  145.            *defined-labels*)
  146.       (when ignored-symbols
  147.     (format s
  148.         "~&*******************  These ignored \"unimplemented\" symbols ~
  149.          were not used.~%~S~%********************~2%"
  150.         ignored-symbols))
  151.       (when ignored-strings
  152.     (format s
  153.         "~&*******************  These ignored \"unimplemented\" strings ~
  154.          were not used.~%~S~%********************~2%"
  155.         ignored-strings)))
  156.     (write-line "@end[comment]" s)
  157.     (values)))
  158.  
  159.  
  160. ;;; Iterate over a string table, checking that each thing has a corresponding
  161. ;;; label of the specified kind.  If there is no label, then call the function
  162. ;;; with the value and stream.  If the label is the wrong kind, print a comment
  163. ;;; on Stream before calling the function.  We also blast the label so we will
  164. ;;; know that it was defined.
  165. ;;;
  166. (defun map-undocumented-hemlock-things (table kind stream function ignore-stuff)
  167.   (do-strings (string value table)
  168.     (let* ((lab (nstring-upcase (remove #\space string)))
  169.        (lkind (gethash lab *defined-labels*)))
  170.       (cond ((and (eq kind :command)
  171.           (member (command-name value) ignore-stuff
  172.               :test #'string-equal))
  173.          (setf ignore-stuff
  174.            (remove (command-name value) ignore-stuff
  175.                :test #'string-equal)))
  176.         ((member value ignore-stuff)
  177.          (setf ignore-stuff (remove value ignore-stuff)))
  178.         (t
  179.          (unless (eq lkind kind)
  180.            (when lkind
  181.          (format stream
  182.              "@comment{~S documented as a ~A, ~
  183.               but defined as a ~A.}~2%"
  184.              string lkind kind))
  185.            (funcall function value stream))))
  186.       (remhash lab *defined-labels*)))
  187.   (when ignore-stuff
  188.     (format stream
  189.         "~&********************  These ignored ~Ss were not used.~%~
  190.          ~S~%********************~2%"
  191.         kind ignore-stuff)))
  192.  
  193.  
  194.  
  195. (defvar *undocumented-symbols-to-ignore*
  196.   '(make-xwindow-like-hwindow mark/= default-font input-waiting mark=
  197.     modify-kbdmac-stream delete-line-font-marks font-mark hemlock-output-stream
  198.     command reprompt store-cut-string make-kbdmac-stream window window-font
  199.     delete-font-mark fetch-cut-string fun-defined-from-pathname
  200.     hemlock-region-stream line< buffer mark< move-font-mark
  201.     editor-describe-function enter-window-autoraise ring mark<= search-pattern
  202.     *print-region* mark>= string-table line mark> line> line>= line<=
  203.     after-editor-initializations *invoke-hook* defhvar))
  204.  
  205. (defun find-undocumented-symbols (package stream)
  206.   (let ((ignore-symbols *undocumented-symbols-to-ignore*))
  207.     (do-external-symbols (sym package)
  208.       (let* ((name (string-trim "*" (symbol-name sym)))
  209.          (kind (gethash name *defined-labels*)))
  210.     (ecase kind
  211.       ((nil)
  212.        (if (member sym ignore-symbols)
  213.            (setf ignore-symbols (remove sym ignore-symbols))
  214.            (let ((*standard-output* stream))
  215.          ;; Bind this to squelch CLOS/DESCRIBE bad interaction.
  216.          (describe sym)
  217.          (terpri)
  218.          (terpri))))
  219.       ((:function :macro :special-form)
  220.        (let ((def (cond ((macro-function sym) :macro)
  221.                 ((special-form-p sym) :special-form)
  222.                 ((fboundp sym) :function))))
  223.          (unless (eq kind def)
  224.            (format stream
  225.                "@comment{~S is ~:[not defined~;~:*defined as a ~A~]~
  226.                 , but is documented as a ~A}~%" sym def kind))))
  227.       (:constant
  228.        (unless (constantp sym)
  229.          (format stream
  230.              "@comment{~S is documented as a constant, but isn't ~
  231.               defined.}~%"
  232.              sym)))
  233.       (:variable
  234.        (unless (or (eq (ext:info variable kind sym) :special)
  235.                (string= name (symbol-name sym)))
  236.            (format stream
  237.                "@comment{~S is documented as a special, but isn't ~
  238.             declared.}~%"
  239.                sym))))
  240.     (remhash name *defined-labels*)))
  241.     (when ignore-symbols
  242.       (format stream
  243.           "~&********************  These ignored symbols were not used.~%~
  244.            ~S~%********************~2%"
  245.           ignore-symbols))))
  246.  
  247.   
  248. (defvar *suffix-codes* (make-hash-table :test #'equal))
  249. (setf (gethash "COM" *suffix-codes*) :command)
  250. (setf (gethash "HVAR" *suffix-codes*) :hemlock-variable)
  251. (setf (gethash "FUN" *suffix-codes*) :function)
  252. (setf (gethash "MAC" *suffix-codes*) :macro)
  253. (setf (gethash "SPEC" *suffix-codes*) :special-form)
  254. (setf (gethash "VAR" *suffix-codes*) :variable)
  255. (setf (gethash "CON" *suffix-codes*) :constant)
  256.  
  257.  
  258. ;;; Parse a line from a Scribe .Aux file, returning the kind of the thing
  259. ;;; documented and its name.
  260. ;;;
  261. (defun parse-label (entry)
  262.   (let* ((end (search "), Value" entry :start2 28))
  263.      (hpos (position #\- entry :start 28 :end end :from-end t)))
  264.     (if hpos
  265.     (let* ((suffix (subseq entry (1+ hpos) end))
  266.            (found (gethash suffix *suffix-codes*)))
  267.       (if found
  268.           (values found (subseq entry 28 hpos))
  269.           (values nil nil)))
  270.     (values nil nil))))
  271.  
  272.  
  273. (defun document-command (command stream)
  274.   (format stream "@defcom[com ~S" (command-name command))
  275.   (let ((binds (command-bindings command)))
  276.     (when binds
  277.       (format stream ", bind (")
  278.       (print-command-bindings binds stream)
  279.       (format stream ")"))
  280.     (format stream "]~%~A~%@enddefcom~2%"
  281.         (command-documentation command))))
  282.  
  283.  
  284. (defun document-variable (var stream)
  285.   (let* ((name (variable-name var :global))
  286.      (len (length name)))
  287.     (unless (string= name "Mode Hook" :start1 (- len 9))
  288.       (format stream "@defhvar[var ~S~@[, val {~(~S~)}~]]~%~A~%@enddefhvar~2%"
  289.           name (variable-value var :global)
  290.           (variable-documentation var :global)))))
  291.  
  292.  
  293. (defvar *definition-pattern*
  294.   (new-search-pattern :string-insensitive :forward "
  295. @def"))
  296.  
  297. (defvar *insert-pattern*
  298.   (new-search-pattern :string-insensitive :backward "
  299.  
  300. "))
  301.  
  302. (defvar *definition-macros* (make-hash-table :test #'equal))
  303. (setf (gethash "COM" *definition-macros*) :command)
  304. (setf (gethash "HVAR" *definition-macros*) :hemlock-variable)
  305. (setf (gethash "UN" *definition-macros*) :function)
  306. (setf (gethash "MAC" *definition-macros*) :macro)
  307. (setf (gethash "SPEC" *definition-macros*) :special-form)
  308. (setf (gethash "VAR" *definition-macros*) :variable)
  309. (setf (gethash "CON" *definition-macros*) :constant)
  310. (setf (gethash "COM1" *definition-macros*) :command)
  311. (setf (gethash "HVAR1" *definition-macros*) :hemlock-variable)
  312. (setf (gethash "UN1" *definition-macros*) :function)
  313. (setf (gethash "MAC1" *definition-macros*) :macro)
  314. (setf (gethash "SPEC1" *definition-macros*) :special-form)
  315. (setf (gethash "VAR1" *definition-macros*) :variable)
  316. (setf (gethash "CON1" *definition-macros*) :constant)
  317.  
  318. (defun parse-doc-macro (line)
  319.   (let* ((bracket (or (position #\[ line)
  320.               (error "No opening #\[ ???")))
  321.      (name (nstring-upcase (subseq line 4 bracket)))
  322.      (kind (gethash name *definition-macros*))
  323.      (nend (case (char line (+ bracket 5))
  324.          (#\"
  325.           (position #\" line :start (+ bracket 6)))
  326.          (#\{
  327.           (position #\} line :start (+ bracket 6)))
  328.          (t nil))))
  329.     (cond ((not kind)
  330.        (format t "Unknown definition macro:~%~A~%" line)
  331.        (values nil nil))
  332.       ((not nend)
  333.        (format t "Can't parse name:~%~A~%" line)
  334.        (values nil nil))
  335.       (t
  336.        (values kind (subseq line (+ bracket 6) nend))))))
  337.  
  338.  
  339. (defun annotate-with-online-documentation (input-file output-file)
  340.   "Take a Scribe input file and produce a Scribe output file with the online
  341.   documentation for each thing inserted before the offline documentation."
  342.   (let* ((temp-buffer (make-buffer "Annotate Temporary"))
  343.      (point (buffer-point temp-buffer)))
  344.     (unwind-protect
  345.     (progn
  346.       (read-file input-file point)
  347.       (buffer-start point)
  348.       (loop
  349.         (unless (find-pattern point *definition-pattern*)
  350.           (return))
  351.         (line-offset point 1)
  352.         (multiple-value-bind
  353.         (kind name)
  354.         (parse-doc-macro (line-string (mark-line point)))
  355.           (when kind
  356.         (with-mark ((insert point :left-inserting))
  357.           (unless (find-pattern insert *insert-pattern*)
  358.             (buffer-start insert))
  359.           (line-offset insert 2 0)
  360.           (with-output-to-mark (stream insert :full)
  361.             (ecase kind
  362.               ((:function :macro :special-form :constant)
  363.                (format stream "@begin[format]~%")
  364.                (let ((*standard-output* stream))
  365.              (describe (intern (string-upcase name))))
  366.                (format stream "~&@end[format]~2%"))
  367.               (:variable
  368.                (format stream "@begin[format]~%")
  369.                (let ((*standard-output* stream))
  370.              (describe (intern (concatenate 'string "*"
  371.                             (string-upcase name)
  372.                             "*"))))
  373.                (format stream "~&@end[format]~2%"))
  374.               (:command
  375.                (let ((command (getstring name *command-names*)))
  376.              (when command
  377.                (format stream "@begin[verse]~%Command @hid[~A]:  ("
  378.                    (command-name command))
  379.                (print-command-bindings (command-bindings command)
  380.                            stream)
  381.                (format stream ")~%@end[verse]~%~A~2&"
  382.                    (command-documentation command)))))
  383.               (:hemlock-variable
  384.                (let ((var (getstring name *global-variable-names*)))
  385.              (when var
  386.                (format stream "@begin[verse]~%Variable @hid[~A]: ~
  387.                (~(~S~))~%@end[verse]~%~A~2&"
  388.                    (variable-name var :global)
  389.                    (variable-value var :global)
  390.                    (variable-documentation var :global))))))
  391.             )))))
  392.       (write-file (buffer-region temp-buffer) output-file))
  393.       (delete-buffer temp-buffer))))
  394.